perm filename MIXSCR.F4[IRC,LCS] blob
sn#375406 filedate 1978-12-14 generic text, type C, neo UTF8
COMMENT ā VALID 00002 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00002 00002 C***** MIXES AND LINKS FILES PUT OUT BY 'SCORE' *******
C00010 ENDMK
Cā;
C***** MIXES AND LINKS FILES PUT OUT BY 'SCORE' *******
C***** ALL FILES MUST HAVE THE .SCR EXTENSION *****
C***** LOAD WITH RENAM.FAI
C***** USE 'R LOADER'. INCLUDE '/LLIB40.OLD[1,3]'. OTHERWISE THERE
C WILL BE READ ERRORS DUE TO BUGS IN CURRENT LIB40 3/77 *******
COMMON /VV/KL,N1,N2,N3,J,K,L,M,P1,PX,A,B,C,D,IBL
COMMON /LNK/ NK,NZ(20),IP /QQQ/QQQ(144) /RRR/RRR(144)
DIMENSION Q(18)
EQUIVALENCE (Q,QQQ)
DATA IBL/' '/
TYPE 24
NK=0
LX=0
ACCEPT 2,K,IP
CALL LO2UP(K)
CALL LO2UP(IP)
IF(K.EQ.'L')LX=-1
200 TYPE 20
ACCEPT 2,N1
IF(N1.EQ.IBL)GO TO 200
CALL LO2UP(N1)
IF(FINDIT(N1))CALL NOTFND(N1)
C DO A LOOKUP FIRST OF ALL
201 TYPE 22
ACCEPT 2,N2
CALL LO2UP(N2)
IF(N2.EQ.IBL.OR.N2.EQ.N1)GO TO 201
IF(FINDIT(N2))CALL NOTFND(N2)
IF(LX.EQ.0)GO TO 202
1000 TYPE 41
ACCEPT 2,K
IF(K.EQ.IBL)GO TO 202
CALL LO2UP(K)
C TAKES UP TO 2+10 FILES.
NK=NK+1
NZ(NK)=K
IF(NK.LT.20)GO TO 1000
202 TYPE 23
ACCEPT 2,N3
IF(N3.EQ.IBL)GO TO 202
CALL LO2UP(N3)
CALL OFILE(1,N3)
TYPE 300
300 FORMAT(' ****** CAUTION ******'/
1' ****** NEVER STOP THIS PROGRAM WHILE IT IS WORKING ******'/)
CALL RENAMX(N1,'SCR',N1,'DAT')
CALL RENAMX(N2,'SCR',N2,'DAT')
CALL IFILE(21,N1)
CALL IFILE(22,N2)
TYPE 25
IF(LX.EQ.0)GO TO 25
CALL LINK
GO TO 204
25 FORMAT(/' WORKING'/)
DO 1 K=1,3
READ(21,2)Q
WRITE(1,2)Q
1 READ(22,2)Q
C READS FIRST 3 LINES
CALL CHECK(N,QQQ,P1,21)
CALL CHECK(M,RRR,PX,22)
CATCHES INSERTED LINES.
6 IF(PX.LT.P1)GO TO 5
CALL RDWRT(N,P1,QQQ,21)
IF(KL)10,6,6
5 CALL RDWRT(M,PX,RRR,22)
IF(KL.EQ.0)GO TO 6
11 PX=10000
GO TO 13
10 P1=10000
13 IF(P1.NE.10000.OR.M.NE.N)GO TO 6
12 WRITE(1,7)
REWIND 21
REWIND 22
CALL RENAMX(N1,'DAT',N1,'SCR')
CALL RENAMX(N2,'DAT',N2,'SCR')
204 END FILE 1
CALL RENAM(N3,'DAT',N3,'SCR')
TYPE 203,N3
CALL EXIT
203 FORMAT(/' ****** MIX FILE NAME = ',A5,'.SCR')
2 FORMAT(18A5)
7 FORMAT(' FINISH;')
24 FORMAT(' MIXES OR LINKS SCORE LISTS.'/
1' USES ".SCR" EXTENSIONS ONLY!!! '/
1' BE SURE ALL HIGHER PARAMS PRINT EACH TIME.'
1//' L = LINK, <CR> = MIX '$)
41 FORMAT(' TYPE NEXT FILE NAME OR <CR> '$)
20 FORMAT(' TYPE FILE 1 (WITHOUT EXT.) '$)
22 FORMAT(/' TYPE FILE 2 '$)
23 FORMAT(/' TYPE OUTPUT NAME '$)
END
SUBROUTINE CHECK(N,Z,P1,J)
COMMON /VV/KL,N1,N2,N3,JJ,KK,L,M,P,PX,LL,K,IBL
1 /QQQ/QQQ(144)
DIMENSION AA(50),Z(144)
DATA J1/7/,J2/12/,J3/21/
C J1,J2,J3 ARE POINTERS TO POS. OF DOTS IN P1,P2
KL=0
33 READ(J,30,END=100)Z
IF(Z(J1).NE.' ')GO TO 32
IF(Z(J2).NE.'.')GO TO 32
IF(Z(J3).EQ.'.')GO TO 31
CATCHES INSERTED LINES.
32 IF(Z(2).NE.'F')GO TO 300
IF(Z(3).NE.'I')GO TO 300
IF(Z(4).NE.'N')GO TO 300
IF(Z(5).NE.'I')GO TO 300
IF(Z(6).NE.'S')GO TO 300
KL=-1
N='FINIS'
300 CALL SHORT(Z)
IF(KL)RETURN
GO TO 33
100 PAUSE 'DIED IN SUBR CHECK'
31 REREAD 4,L,N,P1
30 FORMAT(144A1)
4 FORMAT(A1,A5,F)
44 FORMAT(A1,20A5)
END
SUBROUTINE SHORT(QQQ)
COMMON /VV/KL,N1,N2,N3,JJ,KK,L,M,P,PX,LL,K,A,B,IBL
COMMON /LNK/ NK,NZ(20),IP
DIMENSION QQQ(1)
DO 1 K=144,1,-1
1 IF(QQQ(K).NE.' ')GO TO 2
2 IF(IP.NE.IBL)TYPE 44,(QQQ(LL),LL=1,K)
IF(KL)RETURN
3 WRITE(1,44)(QQQ(LL),LL=1,K)
44 FORMAT(144A1)
END
SUBROUTINE RDWRT(I,P,Z,J)
COMMON /VV/KL,N1,N2,N3,JJ,KK,L,M,P1,PX,LL,K,IBL
DIMENSION Z(144)
KL=0
DO 3 K=144,1,-1
3 IF(Z(K).NE.' ')GO TO 4
4 WRITE(1,44)(Z(N),N=1,K)
1 READ (J,44,END=100)Z
DO 5 K=144,1,-1
5 IF(Z(K).NE.' ')GO TO 6
6 WRITE(1,44)(Z(N),N=1,K)
IF(Z(1).NE.';')GO TO 1
IF(Z(2).NE.'P')GO TO 1
IF(Z(3).NE.'R')GO TO 1
IF(Z(4).NE.'I')GO TO 1
IF(Z(5).NE.'N')GO TO 1
IF(Z(6).NE.'T')GO TO 1
2 CALL CHECK(I,Z,P,J)
RETURN
44 FORMAT(144A1)
100 PAUSE 'DIED IN SUBR RDWRT'
END
SUBROUTINE LINK
COMMON /VV/KL,N1,N2,N3,JJ,KK,L,M,P1,PX,LL,K,IBL
COMMON /LNK/ NK,NZ(20),IP /QQQ/QQQ(144)
44 FORMAT(144A1)
KL=0
JJ=0
J=21
1 READ(J,44)QQQ
32 IF(QQQ(2).NE.'F')GO TO 4
IF(QQQ(3).NE.'I')GO TO 4
IF(QQQ(4).NE.'N')GO TO 4
IF(QQQ(5).NE.'I')GO TO 4
IF(QQQ(6).NE.'S')GO TO 4
GO TO 2
4 CALL SHORT(QQQ)
IF(JJ.GT.NK)RETURN
GO TO 1
2 IF(J.NE.21)GO TO 3
REWIND 21
CALL RENAMX(N1,'DAT',N1,'SCR')
J=J+1
GO TO 1
3 REWIND 22
IF(JJ.NE.0)GO TO 6
CALL RENAMX(N2,'DAT',N2,'SCR')
GO TO 5
6 CALL RENAMX(NZ(JJ),'DAT',NZ(JJ),'SCR')
5 JJ=JJ+1
IF(JJ.GT.NK)GO TO 4
CALL RENAMX(NZ(JJ),'SCR',NZ(JJ),'DAT')
CALL IFILE(22,NZ(JJ))
GO TO 1
END
SUBROUTINE RENAMX(J,K,L,M)
CALL RENAM(J,K,L,M)
TYPE 1,J,K,L,M
1 FORMAT(' (RENAME -- ',A5,'.',A3,' CHANGED TO -- ',A5,'.',A3,')')
END
SUBROUTINE NOTFND(NM)
TYPE 1,NM
CALL EXIT
1 FORMAT(' ******* FILE ',A5,'.SCR NOT FOUND *****')
END
SUBROUTINE LO2UP(J)
C CONVERTS ALL LOWER CASE IN WORD J TO UPPER CASE.
J=J.AND..NOT.((J/2).AND."201004020100)
END